Visual Basic 4 Database How-To/Visual Basic 4 Database - How-to (The Waite Group)(1995).iso/listunb.fr_/listunb.fr

Text File | 1995-07-04 | 19KB | 638 lines

VERSION 4.00
Begin VB.Form Form1
   BackColor       =   &H00C0C0C0&
   Caption         =   "Unbound Lister"
   ClientHeight    =   2745
   ClientLeft      =   1935
   ClientTop       =   2040
   ClientWidth     =   6420
   BeginProperty Font
      name            =   "MS Sans Serif"
      charset         =   0
      weight          =   700
      size            =   8.25
      underline       =   0   'False
      italic          =   0   'False
      strikethrough   =   0   'False
   EndProperty
   Height          =   3435
   Left            =   1875
   LinkTopic       =   "Form1"
   ScaleHeight     =   2745
   ScaleWidth      =   6420
   Top             =   1410
   Width           =   6540
   Begin VB.ComboBox cboPublishers
      Height          =   300
      Left            =   1860
      Sorted          =   -1  'True
      Style           =   2  'Dropdown List
      TabIndex        =   10
      Top             =   1380
      Width           =   4035
   End
   Begin VB.CommandButton cmdMove
      Caption         =   ">|"
      Height          =   375
      Index           =   3
      Left            =   3660
      TabIndex        =   9
      Top             =   2100
      Width           =   375
   End
   Begin VB.CommandButton cmdMove
      Caption         =   ">"
      Height          =   375
      Index           =   2
      Left            =   3300
      TabIndex        =   8
      Top             =   2100
      Width           =   375
   End
   Begin VB.CommandButton cmdMove
      Caption         =   "<"
      Height          =   375
      Index           =   1
      Left            =   2940
      TabIndex        =   7
      Top             =   2100
      Width           =   375
   End
   Begin VB.CommandButton cmdMove
      Caption         =   "|<"
      Height          =   375
      Index           =   0
      Left            =   2580
      TabIndex        =   6
      Top             =   2100
      Width           =   375
   End
   Begin VB.TextBox txtISBN
      DataField       =   "ISBN"
      DataSource      =   "dtaTitles"
      Height          =   315
      Left            =   4260
      MaxLength       =   13
      TabIndex        =   2
      Top             =   900
      Width           =   1635
   End
   Begin VB.TextBox txtYearPublished
      DataField       =   "Year Published"
      DataSource      =   "dtaTitles"
      Height          =   285
      Left            =   1860
      TabIndex        =   1
      Top             =   900
      Width           =   735
   End
   Begin VB.TextBox txtTitle
      DataField       =   "Title"
      DataSource      =   "dtaTitles"
      Height          =   555
      Left            =   1860
      MultiLine       =   -1  'True
      TabIndex        =   0
      Top             =   180
      Width           =   4095
   End
   Begin VB.Label Label4
      AutoSize        =   -1  'True
      BackColor       =   &H00C0C0C0&
      Caption         =   "Publisher:"
      Height          =   195
      Left            =   840
      TabIndex        =   11
      Top             =   1440
      Width           =   855
   End
   Begin VB.Label Label3
      AutoSize        =   -1  'True
      BackColor       =   &H00C0C0C0&
      Caption         =   "ISBN:"
      Height          =   195
      Left            =   3600
      TabIndex        =   5
      Top             =   960
      Width           =   510
   End
   Begin VB.Label Label2
      AutoSize        =   -1  'True
      BackColor       =   &H00C0C0C0&
      Caption         =   "Year Published:"
      Height          =   195
      Left            =   360
      TabIndex        =   4
      Top             =   960
      Width           =   1350
   End
   Begin VB.Label Label1
      AutoSize        =   -1  'True
      BackColor       =   &H00C0C0C0&
      Caption         =   "Title:"
      Height          =   195
      Left            =   1200
      TabIndex        =   3
      Top             =   180
      Width           =   450
   End
   Begin VB.Menu mnuFile
      Caption         =   "&File"
      Begin VB.Menu mnuFileExit
         Caption         =   "E&xit"
      End
   End
   Begin VB.Menu mnuEdit
      Caption         =   "&Edit"
      Begin VB.Menu mnuEditUndo
         Caption         =   "&Undo"
         Shortcut        =   %{BKSP}
      End
   End
   Begin VB.Menu mnuData
      Caption         =   "&Data"
      Begin VB.Menu mnuSaveRecord
         Caption         =   "&Save Record"
      End
      Begin VB.Menu mnuDataIndex
         Caption         =   "&Index"
         Begin VB.Menu mnuDataIndexISBN
            Caption         =   "&ISBN"
         End
         Begin VB.Menu mnuDataIndexTitle
            Caption         =   "&Title"
         End
      End
      Begin VB.Menu mnuDataSeek
         Caption         =   "See&k"
      End
   End
End
Attribute VB_Name = "Form1"
Attribute VB_Creatable = False
Attribute VB_Exposed = False
Option Explicit

Private rsTitles As Recordset
Private rsPublishers As Recordset
Private DataChanged As Boolean
Private DisplayingRecord
Private MoveCancelled As Boolean



Private Sub cmdMove_Click(Index As Integer)

    ' The user clicked one of the move buttons. The button clicked is
    ' passed as the Index argument. The four local Const declarations
    ' represent the possible values of Index

    Const MOVE_FIRST = 0
    Const MOVE_PREVIOUS = 1
    Const MOVE_NEXT = 2
    Const MOVE_LAST = 3

    Dim msg As String

    If DataChanged Then

        ' The data have changed, so verify that the user wants to save
        ' the changes to the database.
        msg = "Do you want to save the changes you've made "
        msg = msg & " to the current Title?"

        Select Case MsgBox(msg, vbQuestion + vbYesNoCancel)
            Case vbYes

                ' The user wants to save.
                SaveRecord
            Case vbNo

                ' The user does not want to save, so simply do nothing

            Case vbCancel

                ' The user clicked Cancel, so set the flag to abort the move
                MoveCancelled = True
        End Select
    End If

    If Not MoveCancelled Then

        ' The move has not been cancelled, so move to the indicated record.
        Select Case Index
            Case MOVE_FIRST
                rsTitles.MoveFirst
            Case MOVE_PREVIOUS
                rsTitles.MovePrevious

                ' If we were already on the first record, moving to the
                ' previous record put us at BOF. That's not good, so
                ' so reposition on the first record.
                If rsTitles.BOF Then rsTitles.MoveFirst
            Case MOVE_NEXT
                rsTitles.MoveNext

                ' If we were already on the last record, moving to the
                ' next record put us at EOF. That's not good, so
                ' so reposition on the last record.
                If rsTitles.EOF Then rsTitles.MoveLast
            Case MOVE_LAST
                rsTitles.MoveLast
        End Select

        ' Read the values from the new current record and display them
        ' in the controls on the form.
        DisplayRecord
    End If

End Sub

Private Sub DisplayRecord()
    Dim i As Integer

    ' Set the DisplayingRecord flag to prevent the cboPublishers_Click
    ' event from changing the DataChanged flag.
    DisplayingRecord = True

    ' Check each field in the recordset to make sure it's non-null.
    ' If it is, display it in the corresponding control. If it is null,
    ' display an empty string in the control.
    If Not IsNull(rsTitles![Title]) Then txtTitle = rsTitles![Title] Else txtTitle = ""
    If Not IsNull(rsTitles![Year Published]) Then txtYearPublished = rsTitles![Year Published] Else txtYearPublished = ""
    If Not IsNull(rsTitles![ISBN]) Then txtISBN = rsTitles![ISBN] Else txtISBN = ""

    ' Search through the ItemData in the publishers list box until a match
    ' for the PubID in the Titles recordset is found. When a match is found,
    ' set the ListIndex to the current item index.
    cboPublishers.ListIndex = -1
    If Not IsNull(rsTitles![PubID]) Then
        For i = 0 To cboPublishers.ListCount - 1
            If cboPublishers.ItemData(i) = rsTitles![PubID] Then
                cboPublishers.ListIndex = i
                Exit For
            End If
        Next i
    End If

    ' Clear the DataChanged flag to indicate there's no need to save the
    ' record.
    DataChanged = False

    ' Clear the Displaying Record flag.
    DisplayingRecord = False
End Sub

Private Sub SaveRecord()
    Dim msg As String

    On Error GoTo SaveError

    ' Verify that each control has a legal value. If a control has an illegal
    ' value, create a string explaining the problem and set the focus to the
    ' control.
    If txtTitle = "" Then
         msg = "You must enter a title."
         txtTitle.SetFocus
    ElseIf txtISBN = "" Then
         msg = "You must enter an ISBN."
         txtISBN.SetFocus
    ElseIf txtYearPublished <> "" And Not IsNumeric(txtYearPublished) Then
        msg = "The Year Published must be numeric."
        txtYearPublished.SetFocus
    ElseIf cboPublishers.ListIndex = -1 Then

        ' If the ListIndex = -1, it means that no list entry is selected.
        msg = "You must enter a publisher."
        txtYearPublished.SetFocus
    End If

    If msg = "" Then

        ' No error message was built, so the data checked out okay. Set
        ' the hourglass cursor.
        Screen.MousePointer = 11

        ' Copy the current record from the recordset rsTitles into the copy buffer.
        rsTitles.Edit

        ' Update the fields in the copy buffer.
        WriteRecord

        ' Write the copy buffer to the database.
        rsTitles.UPDATE

        ' Clear the DataChanged flag to indicate there's no need to save the
        ' record.
        DataChanged = False
        MoveCancelled = False

        ' Restore the cursor to the default.
        Screen.MousePointer = 0
    Else

        ' There's an error message, so display it.
        MsgBox msg, vbExclamation
    End If

Exit Sub

SaveError:

    ' An error was generated by Visual Basic or the Jet engine.
    ' Set the cursor to the default and display the error message.
    Screen.MousePointer = 0
    MsgBox Err.Description

Exit Sub

End Sub

Private Sub WriteRecord()

    ' Update each field in the Titles recordset from the value of the
    ' associated text control on the form.
    rsTitles![Title] = txtTitle
    rsTitles![Year Published] = txtYearPublished
    rsTitles![ISBN] = txtISBN

    ' The PubID field in the Titles recordset gets the PubID of the
    ' selected publisher, which is in the ItemData associated with the
    ' currently selected item in the list box.
    rsTitles![PubID] = cboPublishers.ItemData(cboPublishers.ListIndex)

End Sub


Private Sub Form_Load()
    Dim db As DATABASE
    Dim dbName As String

    On Error GoTo LoadError

  ' Get the database name and open the database.
    dbName = BiblioPath()       ' BiblioPath is a function in READINI.BAS
    Set db = DBEngine.Workspaces(0).OpenDatabase(dbName)

    ' Open the recordset.
    Set rsTitles = db.OpenRecordset("Titles", dbOpenTable)

    If rsTitles.RecordCount > 0 Then

        ' We have at least one record, so open a recordset that will be
        ' used to fill the publishers list box.
        Set rsPublishers = db.OpenRecordset("Publishers", dbOpenTable)

        If rsPublishers.RecordCount > 0 Then

            ' There's at least one publisher, so fill the list box.
            ' Begin by positioning on the first record in the publishers
            ' recordset.

            rsPublishers.MoveFirst

            Do
                If Not IsNull(rsPublishers![Company Name]) Then

                    ' Add the company name to the list.
                    cboPublishers.AddItem rsPublishers![Company Name]

                    ' Associate the PubID with its associated company name.
                    cboPublishers.ItemData(cboPublishers.NewIndex) = _
                        rsPublishers![PubID]
                End If

                ' Move to the next record in the publishers recordset.
                rsPublishers.MoveNext

            ' If there are publisher records left to process, keep going.
            Loop While Not rsPublishers.EOF


        End If

        ' display the values of the first record in the recordset in
        ' the controls on the form.
        DisplayRecord

        ' Set the current index to the default, which is the primary key.
        UpdateMenuStatus "PrimaryKey"

    Else

        ' An empty recordset, so display an explanation, then terminate.
        MsgBox "There are no records in the Titles table.", vbCritical
        End
    End If
Exit Sub

LoadError:

    ' An error was generated by Visual Basic or the Jet engine.
    ' Display the error message and terminate gracefully.
    MsgBox Err.Description
End

End Sub


Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)

    ' Somebody wants to close the form.

    Dim msg As String

    On Error GoTo CloseError

    If DataChanged Then

        ' The user has changed data in the current record. Ask whether
        ' the user wants to save the changes.
        msg = "Do you want to save changes to the current record?"

        Select Case MsgBox(msg, vbQuestion + vbYesNoCancel)
            Case vbYes

                ' The user said yes, so save the changes.
                SaveRecord

            Case vbNo

                ' The user said no, so do nothing.
            Case vbCancel

                ' The user clicked Cancel, so cancel the unload event.
                Cancel = True
        End Select
    End If

Exit Sub
CloseError:
    Dim errorMsg As String

    ' An error was generated by Visual Basic or the Jet engine.
    ' Display the error message.
    errorMsg = "Error " & Err & " (" & Error$ & ") occurred."
    errorMsg = errorMsg & " RECORD HAS NOT BEEN SAVED!!"
    MsgBox errorMsg, vbExclamation

    ' Set the DataChanged flag.
    txtTitle.DataChanged = True
Exit Sub

End Sub

Private Sub mnuEditUndo_Click()

    ' The user clicked Undo, so refresh the controls on the form with
    ' the contents of the current record in the recordset.
    DisplayRecord
End Sub

Private Sub mnuFileExit_Click()
    Unload Me
End Sub

Private Sub mnuSaveRecord_Click()

    ' If the record needs to be saved, save it. Otherwise, just ignore
    ' the click.
    If DataChanged Then SaveRecord
End Sub

Private Sub txtISBN_Change()

    ' The user has made a change, so set the DataChanged flag to true to
    ' indicate that the record needs to be saved.
    DataChanged = True
End Sub

Private Sub txtTitle_Change()

    ' The user has made a change, so set the DataChanged flag to true to
    ' indicate that the record needs to be saved.
    DataChanged = True
End Sub

Private Sub txtYearPublished_Change()

    ' The user has made a change, so set the DataChanged flag to true to
    ' indicate that the record needs to be saved.
    DataChanged = True
End Sub

Private Sub cboPublishers_Click()

    If Not DisplayingRecord Then

        ' We are not in the process of changing to a new record, so if
        ' the user changed to a new publisher, set the DataChanged flag to
        ' True to indicate that the record needs to be saved.
        If cboPublishers.ItemData(cboPublishers.ListIndex) <> _
            rsTitles![PubID] Then DataChanged = True
    End If
End Sub


Private Sub mnuDataIndexISBN_Click()
    Dim db As DATABASE
    Dim bkMark As Variant

    ' Mark the current position.
    bkMark = rsTitles.Bookmark

    ' The user clicked the ISBN choice on the Index pop-oup menu. Set
    ' the recordset index to the primary key, which is the ISBN field.
    rsTitles.Index = "PrimaryKey"

    ' Check the ISBN choice on the menu.
    UpdateMenuStatus "PrimaryKey"

    ' Reset to the marked position.
    rsTitles.Bookmark = bkMark
End Sub

Private Sub mnuDataIndexTitle_Click()
    Dim db As DATABASE
    Dim bkMark As Variant

    ' Mark the current position.
    bkMark = rsTitles.Bookmark

    ' The user clicked the Title choice on the Index pop-oup menu. Set
    ' the recordset index to the Title index.
    rsTitles.Index = "Title"

    ' Check the Title choice on the menu.
    UpdateMenuStatus "Title"

    ' Reset to the marked position.
    rsTitles.Bookmark = bkMark
End Sub

Private Sub mnuDataSeek_Click()
    Dim seekWhat As String
    Dim currentIndex As String
    Dim bkMark As Variant

    ' Mark the current record.
    bkMark = rsTitles.Bookmark

    ' Find out what the currently active index is.

    currentIndex = GetCurrentIndexState()

    ' Get the value(s) from the user to be sought.

    If currentIndex = "ISBN" Then
        seekWhat = InputBox$("ISBN to seek:", "Customer List")
    Else
        seekWhat = InputBox$("State to seek:", "Customer List")
    End If

    ' Seek the requested record. The first argument to the Seek method is
    ' the type of comparison; in this case, it's an equality. The remaining
    ' arguments are the fields in the selected index.

    rsTitles.Seek "=", seekWhat

    ' If the seek was successful, it points the record pointer to the first
    ' record matching the criteria. In this case, just refresh the form.
    ' If the seek was unsuccessful, inform the user and return to the
    ' originally displayed record.

    If Not rsTitles.NoMatch Then
        DisplayRecord
    Else
        MsgBox "Record sought not found!", vbExclamation, "Customer List"
        rsTitles.Bookmark = bkMark
    End If

End Sub
Private Function GetCurrentIndexState() As String

    ' This function returns the name of the currently active index.
    ' It determines the index by seeing which Index menu item is checked.

    If mnuDataIndexISBN.Checked Then
        GetCurrentIndexState = "ISBN"
    Else
        GetCurrentIndexState = "TITLE"
    End If
End Function

Private Sub UpdateMenuStatus(ActiveIndex As String)

    ' This routine places a check mark beside the currently selected indexing
    ' method.

    ' Check the appropriate menu item based on the ActiveIndex argument.
    ' Uncheck all the others.

    mnuDataIndexISBN.Checked = IIf(ActiveIndex = "PrimaryKey", True, False)
    mnuDataIndexTitle.Checked = IIf(ActiveIndex = "Title", True, False)

End Sub